home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / serve-event.lisp < prev    next >
Encoding:
Text File  |  1992-12-14  |  15.6 KB  |  483 lines

  1. ;;; -*- Log: code.log; Package: LISP -*-
  2.  
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: serve-event.lisp,v 1.19 92/12/14 14:39:44 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; SYSTEM:SERVE-EVENT, now in it's own file.
  15. ;;;
  16. ;;; Re-written by William Lott, July 1989 - January 1990.
  17. ;;; 
  18. ;;; **********************************************************************
  19.  
  20. (in-package "SYSTEM")
  21.  
  22. (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
  23.       serve-event serve-all-events wait-until-fd-usable
  24.       make-object-set object-set-operation *xwindow-table*
  25.       map-xwindow add-xwindow-object remove-xwindow-object))
  26.  
  27. (in-package "EXTENSIONS")
  28.  
  29. (export '(*display-event-handlers*))
  30.  
  31. (in-package "LISP")
  32.  
  33.  
  34.  
  35. ;;;; Object set stuff.
  36.  
  37. ;;;
  38. ;;;    Hashtable from ports to objects.  Each entry is a cons (object . set).
  39. ;;;
  40. ;(defvar *port-table* (make-hash-table :test #'eql))
  41.  
  42. ;;; Hashtable from windows to objects.  Each entry is a cons (object . set).
  43. ;;;
  44. (defvar *xwindow-table* (make-hash-table :test #'eql))
  45.  
  46.  
  47. (defstruct (object-set
  48.         (:constructor make-object-set
  49.               (name &optional
  50.                 (default-handler #'default-default-handler)))
  51.         (:print-function
  52.          (lambda (s stream d)
  53.            (declare (ignore d))
  54.            (format stream "#<Object Set ~S>" (object-set-name s)))))
  55.   name                    ; Name, for descriptive purposes.
  56.   (table (make-hash-table :test #'eq))  ; Message-ID or xevent-type --> handler fun.
  57.   default-handler)
  58.  
  59. (setf (documentation 'make-object-set 'function)
  60.       "Make an object set for use by a RPC/xevent server.  Name is for
  61.       descriptive purposes only.")
  62.  
  63. ;;; Default-Default-Handler  --  Internal
  64. ;;;
  65. ;;;    If no such operation defined, signal an error.
  66. ;;;
  67. (defun default-default-handler (object)
  68.   (error "You lose, object: ~S" object))
  69.  
  70.  
  71. ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
  72. ;;; object set mapped to by a xwindow or port in *xwindow-table* or
  73. ;;; *port-table*.
  74. ;;; 
  75. (macrolet ((defmapper (name table)
  76.           `(defun ,(intern (concatenate 'simple-string
  77.                         "MAP-" (symbol-name name)))
  78.               (,name)
  79.          ,(format nil "Return as multiple values the object and ~
  80.                        object-set mapped to by ~A."
  81.               (string-downcase (symbol-name name)))
  82.          (let ((temp (gethash ,name ,table)))
  83.            (if temp
  84.                (values (car temp) (cdr temp))
  85.                (values nil nil))))))
  86.   ;(defmapper port *port-table*)
  87.   (defmapper xwindow *xwindow-table*))
  88.  
  89.  
  90. ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
  91. ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
  92. ;;; 
  93. (macrolet ((def-add-object (name table)
  94.           `(defun ,(intern (concatenate 'simple-string
  95.                         "ADD-" (symbol-name name)
  96.                         "-OBJECT"))
  97.               (,name object object-set)
  98.          ,(format nil "Add a new ~A/object/object-set association."
  99.               (string-downcase (symbol-name name)))
  100.          (check-type object-set object-set)
  101.          (setf (gethash ,name ,table) (cons object object-set))
  102.          object)))
  103.   ;(def-add-object port *port-table*)
  104.   (def-add-object xwindow *xwindow-table*))
  105.  
  106.  
  107. ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
  108. ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
  109. ;;; 
  110. (macrolet ((def-remove-object (name table)
  111.           `(defun ,(intern (concatenate 'simple-string
  112.                         "REMOVE-" (symbol-name name)
  113.                         "-OBJECT"))
  114.               (,name)
  115.          ,(format nil
  116.               "Remove ~A and its associated object/object-set pair."
  117.               (string-downcase (symbol-name name)))
  118.          (remhash ,name ,table))))
  119.   ;(def-remove-object port *port-table*)
  120.   (def-remove-object xwindow *xwindow-table*))
  121.  
  122.  
  123. ;;; Object-Set-Operation  --  Public
  124. ;;;
  125. ;;;    Look up the handler function for a given message ID.
  126. ;;;
  127. (defun object-set-operation (object-set message-id)
  128.   "Return the handler function in Object-Set for the operation specified by
  129.    Message-ID, if none, NIL is returned."
  130.   (check-type object-set object-set)
  131.   (check-type message-id fixnum)
  132.   (values (gethash message-id (object-set-table object-set))))
  133.  
  134. ;;; %Set-Object-Set-Operation  --  Internal
  135. ;;;
  136. ;;;    The setf inverse for Object-Set-Operation.
  137. ;;;
  138. (defun %set-object-set-operation (object-set message-id new-value)
  139.   (check-type object-set object-set)
  140.   (check-type message-id fixnum)
  141.   (setf (gethash message-id (object-set-table object-set)) new-value))
  142. ;;;
  143. (defsetf object-set-operation %set-object-set-operation
  144.   "Sets the handler function for an object set operation.")
  145.  
  146.  
  147.  
  148. ;;;; File descriptor IO noise.
  149.  
  150. (defstruct (handler
  151.         (:print-function %print-handler)
  152.         (:constructor make-handler (direction descriptor function)))
  153.   (direction nil :type (member :input :output)) ; Either :input or :output
  154.   (descriptor 0 :type (mod 32)) ; File descriptor this handler is tied to.
  155.   active              ; T iff this handler is running.
  156.   (function nil :type function) ; Function to call.
  157.   bogus                  ; T if this descriptor is bogus. 
  158.   )
  159.  
  160. (defun %print-handler (handler stream depth)
  161.   (declare (ignore depth))
  162.   (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
  163.       (handler-direction handler)
  164.       (handler-bogus handler)
  165.       (handler-descriptor handler)
  166.       (handler-function handler)))
  167.  
  168. (defvar *descriptor-handlers* nil
  169.   "List of all the currently active handlers for file descriptors")
  170.  
  171.  
  172. ;;; ADD-FD-HANDLER -- public
  173. ;;;
  174. ;;;   Add a new handler to *descriptor-handlers*.
  175. ;;;
  176. (defun add-fd-handler (fd direction function)
  177.   "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
  178.   either :INPUT or :OUTPUT. The value returned should be passed to
  179.   SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
  180.   (assert (member direction '(:input :output))
  181.       (direction)
  182.       "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
  183.   (let ((handler (make-handler direction fd function)))
  184.     (push handler *descriptor-handlers*)
  185.     handler))
  186.  
  187. ;;; REMOVE-FD-HANDLER -- public
  188. ;;;
  189. ;;;   Remove an old handler from *descriptor-handlers*.
  190. ;;;
  191. (defun remove-fd-handler (handler)
  192.   "Removes HANDLER from the list of active handlers."
  193.   (setf *descriptor-handlers*
  194.     (delete handler *descriptor-handlers*
  195.         :test #'eq)))
  196.  
  197. ;;; INVALIDATE-DESCRIPTOR -- public
  198. ;;;
  199. ;;;   Search *descriptor-handlers* for any reference to fd, and nuke 'em.
  200. ;;; 
  201. (defun invalidate-descriptor (fd)
  202.   "Remove any handers refering to fd. This should only be used when attempting
  203.   to recover from a detected inconsistancy."
  204.   (setf *descriptor-handlers*
  205.     (delete fd *descriptor-handlers*
  206.         :key #'handler-descriptor)))
  207.  
  208. ;;; WITH-FD-HANDLER -- Public.
  209. ;;;
  210. ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
  211. ;;;
  212. (defmacro with-fd-handler ((fd direction function) &rest body)
  213.   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
  214.    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
  215.    use, and FUNCTION is the function to call whenever FD is usable."
  216.   (let ((handler (gensym)))
  217.     `(let (,handler)
  218.        (unwind-protect
  219.        (progn
  220.          (setf ,handler (add-fd-handler ,fd ,direction ,function))
  221.          ,@body)
  222.      (when ,handler
  223.        (remove-fd-handler ,handler))))))
  224.  
  225.  
  226. ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
  227. ;;;
  228. ;;; First, get a list and mark bad file descriptors.  Then signal an error
  229. ;;; offering a few restarts.
  230. ;;;
  231. (defun handler-descriptors-error ()
  232.   (let ((bogus-handlers nil))
  233.     (dolist (handler *descriptor-handlers*)
  234.       (unless (or (handler-bogus handler)
  235.           (unix:unix-fstat (handler-descriptor handler)))
  236.     (setf (handler-bogus handler) t)
  237.     (push handler bogus-handlers)))
  238.     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
  239.              bogus-handlers (length bogus-handlers))
  240.       (remove-them () :report "Remove bogus handlers."
  241.        (setf *descriptor-handlers*
  242.          (delete-if #'handler-bogus *descriptor-handlers*)))
  243.       (retry-them () :report "Retry bogus handlers."
  244.        (dolist (handler bogus-handlers)
  245.      (setf (handler-bogus handler) nil)))
  246.       (continue () :report "Go on, leaving handlers marked as bogus."))))
  247.  
  248.  
  249.  
  250. ;;;; Serve-all-events, serve-event, and friends.
  251.  
  252. (declaim (start-block wait-until-fd-usable start-block serve-event
  253.               serve-all-events))
  254.  
  255. ;;; DECODE-TIMEOUT  --  Internal
  256. ;;;
  257. ;;;    Break a real timeout into seconds and microseconds.
  258. ;;;
  259. (defun decode-timeout (timeout)
  260.   (declare (values (or index null) index))
  261.   (typecase timeout
  262.     (integer (values timeout 0))
  263.     (null (values nil 0))
  264.     (real
  265.      (multiple-value-bind (q r)
  266.               (truncate (coerce timeout 'single-float))
  267.        (declare (type index q) (single-float r))
  268.        (values q (the index (truncate (* r 1f6))))))
  269.     (t
  270.      (error "Timeout is not a real number or NIL: ~S" timeout))))
  271.  
  272.  
  273. ;;; WAIT-UNTIL-FD-USABLE -- Public.
  274. ;;;
  275. ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
  276. ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
  277. ;;; timeout at the correct time irrespective of how many events are handled in
  278. ;;; the meantime.
  279. ;;;
  280. (defun wait-until-fd-usable (fd direction &optional timeout)
  281.   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
  282.   :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
  283.   up."
  284.   (declare (type (or real null) timeout))
  285.   (let (usable)
  286.     (multiple-value-bind (to-sec to-usec)
  287.              (decode-timeout timeout)
  288.       (declare (type (or index null) to-sec to-usec))
  289.       (multiple-value-bind
  290.       (stop-sec stop-usec)
  291.       (if to-sec
  292.           (multiple-value-bind (okay start-sec start-usec)
  293.                    (unix:unix-gettimeofday)
  294.         (declare (ignore okay))
  295.         (let ((usec (+ to-usec start-usec))
  296.               (sec (+ to-sec start-sec)))
  297.           (declare (type (unsigned-byte 31) usec sec))
  298.           (if (>= usec 1000000)
  299.               (values (1+ sec) (- usec 1000000))
  300.               (values sec usec))))
  301.           (values 0 0))
  302.     (declare (type (unsigned-byte 31) stop-sec stop-usec))
  303.     (with-fd-handler (fd direction #'(lambda (fd)
  304.                        (declare (ignore fd))
  305.                        (setf usable t)))
  306.       (loop
  307.         (sub-serve-event to-sec to-usec)
  308.         
  309.         (when usable
  310.           (return t))
  311.         
  312.         (when timeout
  313.           (multiple-value-bind (okay sec usec)
  314.                    (unix:unix-gettimeofday)
  315.         (declare (ignore okay))
  316.         (when (or (> sec stop-sec)
  317.               (and (= sec stop-sec) (>= usec stop-usec)))
  318.           (return nil))
  319.         (setq to-sec (- stop-sec sec))
  320.         (cond ((> usec stop-usec)
  321.                (decf to-sec)
  322.                (setq to-usec (- (+ stop-usec 1000000) usec)))
  323.               (t
  324.                (setq to-usec (- stop-usec usec))))))))))))
  325.  
  326.  
  327. (defvar *display-event-handlers* nil
  328.   "This is an alist mapping displays to user functions to be called when
  329.    SYSTEM:SERVE-EVENT notices input on a display connection.  Do not modify
  330.    this directly; use EXT:ENABLE-CLX-EVENT-HANDLING.  A given display
  331.    should be represented here only once.")
  332.  
  333. ;;; SERVE-ALL-EVENTS -- public
  334. ;;;
  335. ;;;   Wait for up to timeout seconds for an event to happen. Make sure all
  336. ;;; pending events are processed before returning.
  337. ;;;
  338. (defun serve-all-events (&optional timeout)
  339.   "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout.  If
  340.   SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
  341.   0 until all events have been served.  SERVE-ALL-EVENTS returns T if
  342.   SERVE-EVENT did something and NIL if not."
  343.   (do ((res nil)
  344.        (sval (serve-event timeout) (serve-event 0)))
  345.       ((null sval) res)
  346.     (setq res t)))
  347.  
  348.  
  349. ;;; SERVE-EVENT -- public
  350. ;;;
  351. ;;;   Serve a single event.
  352. ;;;
  353. (defun serve-event (&optional timeout)
  354.   "Receive on all ports and Xevents and dispatch to the appropriate handler
  355.   function.  If timeout is specified, server will wait the specified time (in
  356.   seconds) and then return, otherwise it will wait until something happens.
  357.   Server returns T if something happened and NIL otherwise."
  358.   (multiple-value-bind (to-sec to-usec)
  359.                (decode-timeout timeout)
  360.     (sub-serve-event to-sec to-usec)))
  361.  
  362.  
  363. ;;; Check for any X displays with pending events.
  364. ;;;
  365. (defun handle-queued-clx-event ()
  366.   (dolist (d/h *display-event-handlers*)
  367.     (let* ((d (car d/h))
  368.        (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
  369.       (declare (inline member))
  370.       ;;
  371.       ;; If in the *descriptor-handlers*, then we are already waiting for input
  372.       ;; on that display, and we don't want to do it recursively.
  373.       (when (and (dolist (hand *descriptor-handlers* t)
  374.            (when (and (eql (handler-descriptor hand) disp-fd)
  375.                   (not (eq (handler-function hand)
  376.                        #'ext::call-display-event-handler)))
  377.              (return nil)))
  378.          (xlib::event-listen d))
  379.     (handler-bind ((error #'(lambda (condx)
  380.                   (declare (ignore condx))
  381.                   (flush-display-events d))))
  382.       (unless (funcall (cdr d/h) d)
  383.         (disable-clx-event-handling d)
  384.         (error "Event-listen was true, but handler didn't handle: ~%~S"
  385.            d/h)))
  386.     (return-from handle-queued-clx-event t)))))
  387.  
  388.  
  389. ;;; Call file descriptor handlers according to the readable and writable masks
  390. ;;; returned by select.
  391. ;;;
  392. (defun call-fd-handler (readable writeable)
  393.   (let ((result nil))
  394.     (dolist (handler *descriptor-handlers*)
  395.       (when (logbitp (handler-descriptor handler)
  396.              (ecase (handler-direction handler)
  397.                (:input readable)
  398.                (:output writeable)))
  399.     (unwind-protect
  400.         (progn
  401.           ;; Doesn't work -- ACK
  402.           ;(setf (handler-active handler) t)
  403.           (funcall (handler-function handler)
  404.                (handler-descriptor handler)))
  405.       (setf (handler-active handler) nil))
  406.     (macrolet ((frob (var)
  407.              `(setf ,var
  408.                 (logand (32bit-logical-not
  409.                      (ash 1
  410.                       (handler-descriptor
  411.                        handler)))
  412.                     ,var))))
  413.       (ecase (handler-direction handler)
  414.         (:input (frob readable))
  415.         (:output (frob writeable))))
  416.     (setf result t)))
  417.     result))
  418.  
  419.  
  420. ;;; SUB-SERVE-EVENT  --  Internal
  421. ;;;
  422. ;;;    Takes timeout broken into seconds and microseconds.
  423. ;;;
  424. (defun sub-serve-event (to-sec to-usec)
  425.   (when (handle-queued-clx-event)
  426.     (return-from sub-serve-event t))
  427.  
  428.   ;; Next, wait for something to happen.
  429.   (multiple-value-bind
  430.       (value readable writeable)
  431.       (multiple-value-bind (count read-mask write-mask except-mask)
  432.                (calc-masks)
  433.     ;; Do the select.
  434.     (unix:unix-select count read-mask write-mask except-mask
  435.               to-sec to-usec))
  436.     (declare (type (unsigned-byte 32) readable)
  437.          (type (or (unsigned-byte 32) null) writeable))
  438.     ;; Now see what it was (if anything)
  439.     (cond ((fixnump value)
  440.        (unless (zerop value)
  441.          (call-fd-handler readable writeable)))
  442.       ((eql readable unix:eintr)
  443.        ;; We did an interrupt.
  444.        t)
  445.       (t
  446.        ;; One of the file descriptors is bad.
  447.        (handler-descriptors-error)
  448.        nil))))
  449.  
  450.  
  451. ;;; CALC-MASKS -- Internal.
  452. ;;;
  453. ;;; Return the correct masks to use for UNIX-SELECT.  The four return values
  454. ;;; are: fd count, read mask, write mask, and exception mask.  The exception
  455. ;;; mask is currently unused.
  456. ;;;
  457. (defun calc-masks ()
  458.   (let ((count 0)
  459.     (read-mask 0)
  460.     (write-mask 0)
  461.     (except-mask 0))
  462.     (declare (type index count)
  463.          (type (unsigned-byte 32) read-mask write-mask except-mask))
  464.     (dolist (handler *descriptor-handlers*)
  465.       (unless (or (handler-active handler)
  466.           (handler-bogus handler))
  467.     (let ((fd (handler-descriptor handler)))
  468.       (ecase (handler-direction handler)
  469.         (:input
  470.          (setf read-mask
  471.            (logior read-mask
  472.                (the (unsigned-byte 32) (ash 1 fd)))))
  473.         (:output
  474.          (setf write-mask
  475.            (logior write-mask
  476.                (the (unsigned-byte 32) (ash 1 fd))))))
  477.       (when (> fd count)
  478.         (setf count fd)))))
  479.     (values (1+ count)
  480.         read-mask
  481.         write-mask
  482.         except-mask)))
  483.